Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Applications/TCPExample/PNL Libraries/MyUtils.p

Text File | 1997-06-06 | 14.5 KB | 630 lines | [TEXT/CWIE]

unit MyUtils;

interface

    uses
        Quickdraw, Types, TextUtils, Events, Windows, MyTypes;

    const
        my_font_strh_id = 1900;

    type
        SavedWindowInfo = record
                oldport: GrafPtr;
                thisport: GrafPtr;
                font: integer;
                size: integer;
                face: Style;
            end;

    type
        MyFontType = (
                MFT_Geneva0, MFT_Geneva9, MFT_Geneva12,
                MFT_Courier0, MFT_Courier9, MFT_Courier12,
                MFT_Chicago0, MFT_Chicago9, MFT_Chicago12,
                MFT_System0, MFT_System9, MFT_System12,
                MFT_Monaco0, MFT_Monaco9, MFT_Monaco12
                );

    procedure GetIndFont( resid: integer; index: integer; var font, size:integer);
    procedure GetMyFonts(ft:MyFontType; var font, size:integer);
    procedure SetMyFont(ft:MyFontType);
    function MyTrapAvailable (tNumber: INTEGER): BOOLEAN;
    function MyNumToString (n: longint): Str255;
    function NumToK(n:longint; extra:boolean):Str255;
    function NumToJustK(n: longint): Str255;
    function NumToStr (n: longint): Str15;
    function SafeNumToStr( n: longint ): Str15; { interrupt safe }
    function SafeStrToNum( const s: string; var n: longint ): boolean; { interrupt safe }
    function UNumToStr( n: longint ): Str15;
    function NN (n: longint; len: integer): Str15;
    function N2 (n: longint): Str15;
    function HexN (n: longint): Char;
    function HexN2 (n: longint): Str15;
    function HexNN (n: longint; len: integer): Str15;
    function HexToNum (s: Str15): longint;
    function StrToNum (s: Str255): longint;
    procedure DotDotDot (var s: Str255; var width: integer);
    function CountSICN( typ: OSType; id: integer ): integer;
    procedure PlotSICN (typ:OSType; id, index, v, h: integer);
    function LookupStrH (id: integer; match: Str255): Str255;
    function LookupStrhNumber (id: integer; n: longint): Str255;
    function DirtyKey (ch: char): boolean;
    function SendCharToIsDialogEvent (const er: EventRecord; cs: CharSet): boolean;
    function GetVersionFromResFile: longint;
    procedure MySetTrapAddress (addr: UniversalProcPtr; trapword: integer);
    function MyGetTrapAddress (trapword: integer): UniversalProcPtr;
    procedure SafeDeviceLoop (drawingRgn: RgnHandle; drawingProc: DeviceLoopDrawingUPP; userData: univ longint; flags: DeviceLoopFlags);
    procedure SafeDeviceLoopRect (drawingRect: Rect; drawingProc: DeviceLoopDrawingUPP; userData: univ longint; flags: DeviceLoopFlags);
{ procedure drawingProc (depth: integer; deviceFlags: integer; targetDevice: GDHandle; item: longint); }
    procedure MakeRGBColor (red, green, blue: UInt16; var col: RGBColor);
    function IsExtension (const name, ext: Str255): boolean;
    function IsPrefix (const name, prefix: Str255): boolean;
{    function TPbtst(value:longint; bit:integer):Boolean;}
    procedure SetInvertHiliteMode;
    procedure HiliteInvertRect (r: Rect);
    procedure HiliteInvertRgn (r: RgnHandle);
    procedure FixScrap;
    procedure HaveResources;
    function MapErr( err: OSStatus ) : OSErr;
    function RandBelow( n: longint ): longint;
    function RandBetween( a, b: longint ): longint;
    procedure AddOSErr( var err: OSErr; err2: OSErr );
    procedure AddOSStatus( var err: OSStatus; err2: OSStatus );
    procedure DrawCenteredString( h, v: integer; const s: string );

implementation

    uses
        Scrap, SegLoad, QuickdrawText, OSUtils, Packages, ToolUtils, Resources,
        Memory, Processes, Folders, Traps, Fonts,
        MyStrings, MyEvents, MyAssertions, MyMemory;

    const
        HiliteMode = $938;

    procedure SetInvertHiliteMode;
    begin
        BitClr(POINTER(HiliteMode), pHiliteBit);
    end;

    procedure HiliteInvertRect (r: Rect);
    begin
        SetInvertHiliteMode;
        InvertRect(r);
    end;

    procedure HiliteInvertRgn (r: RgnHandle);
    begin
        SetInvertHiliteMode;
        InvertRgn(r);
    end;
{
    function TPbtst(value:longint; bit:integer):Boolean;
    begin
        TPbtst := btst(value, bit);
    end;
}
    procedure GetIndFont( resid: integer; index: integer; var font, size:integer);
        var
            s:Str255;
            n:longint;
    begin
        GetIndString( s, resid, index );
        Assert( s <> '' );
        GetFNum( s, font );
        GetIndString( s, resid, index + 1 );
        Assert( s <> '' );
        StringToNum( s, n );
        size := n;
    end;

    procedure GetMyFonts(ft:MyFontType; var font, size:integer);
    begin
        GetIndFont( my_font_strh_id, 2*ord(ft) + 1, font, size );
    end;

    procedure SetMyFont(ft:MyFontType);
        var
            font, size:integer;
    begin
        GetMyFonts(ft, font, size);
        TextFont(font);
        TextSize(size);
    end;

    function IsExtension (const name, ext: Str255): boolean;
        var
            pn, pe: integer;
    begin
        if false then begin
            IsExtension := IUEqualString(TPcopy(name, length(name) - length(ext) + 1, 255), ext) = 0;
        end else begin
            IsExtension := false;
            if length(name) >= length(ext) then begin
                pn := length(name) - length(ext) + 1;
                pe := 1;
                while pe <= length(ext) do begin
                    if UpCaseChar(name[pn]) <> UpCaseChar(ext[pe]) then begin
                        leave;
                    end;
                    pn := pn + 1;
                    pe := pe + 1;
                end;
                IsExtension := pe > length(ext);
            end;
        end;
    end;

    function IsPrefix (const name, prefix: Str255): boolean;
    begin
        IsPrefix := IUEqualString(TPcopy(name, 1, length(prefix)), prefix) = 0;
    end;

    procedure MakeRGBColor (red, green, blue: UInt16; var col: RGBColor);
    begin
        col.red := red;
        col.green := green;
        col.blue := blue;
    end;

    procedure SafeDeviceLoop (drawingRgn: RgnHandle; drawingProc: DeviceLoopDrawingUPP; userData: univ longint; flags: DeviceLoopFlags);
    begin
        Assert( drawingProc <> nil );
        if MyTrapAvailable(_DeviceLoop) then begin
            DeviceLoop(drawingRgn, drawingProc, userData, flags);
        end else begin
            CallDeviceLoopDrawingProc(1, 0, nil, userData, drawingProc);
        end;
    end;

    procedure SafeDeviceLoopRect (drawingRect: Rect; drawingProc: DeviceLoopDrawingUPP; userData: univ longint; flags: DeviceLoopFlags);
        var
            rgn: RgnHandle;
    begin
        rgn := NewRgn;
        RectRgn(rgn, drawingRect);
        SafeDeviceLoop(rgn, drawingProc, userData, flags);
        DisposeRgn(rgn);
    end;

    function GetVersionFromResFile: longint;
        var
            versh: VersRecHndl;
    begin
        GetVersionFromResFile := 0;
        versh := VersRecHndl(Get1Resource('vers', 1));
        if versh <> nil then begin
            GetVersionFromResFile := longint(versh^^.numericVersion);
        end; (* if *)
    end;

    function MyTrapAvailable (tNumber: INTEGER): BOOLEAN;
{Check to see if a given trap is implemented. Babble as taken from IM6 }
        const
            TrapMask = $0800;
        var
            tType: TrapType;
            numtraps: integer;
    begin
        tType := TrapType(btst(tNumber, 11));
        if (tType = ToolTrap) then begin
            if NGetTrapAddress($A86E, ToolTrap) = NGetTrapAddress($AA6E, ToolTrap) then begin
                numtraps := $0200;
            end else begin
                numtraps := $0400;
            end;
            if BAND(tNumber, $07FF) >= numtraps then begin
                tNumber := _Unimplemented;
            end;
        end;
        MyTrapAvailable := MyGetTrapAddress(tNumber) <> MyGetTrapAddress(_Unimplemented);
    end;

    function MyNumToString (n: longint): Str255;
        var
            s, t: Str255;
    begin
        if abs(n) < 4096 then begin
            NumToString(n, s)
        end else if abs(n) < 4194304 then begin
            NumToString(n div 1024, s);
            GetIndString(t, 935, 2);
            s := Concat(s, t);
        end else begin
            GetIndString(t, 935, 3);
            NumToString(n div 1048576, s);
            s := Concat(s, t);
        end;
        MyNumToString := s;
    end;

    function NumToJustK(n: longint): Str255;
        var
            t: Str255;
    begin
        GetIndString(t, 935, 2);
        NumToJustK := concat(NumToStr((n + 1023) div 1024), t);
    end;

    function NumToK(n:longint; extra:boolean):Str255;
        const
            K = 1024;
            M = 1048576;
        var
            f:integer;
            s, dot:Str255;
    begin
        if (n < 1048576) & extra then begin
            n := n*1024;
            extra := false;
        end;
        if (n < K) then begin
            { extra is false }
            NumToString(n,s);
        end else begin
            { n >= K }
            f := ord(extra);
            while n >= M do begin
                f := f + 1;
                n := n div K;
            end;
            { K <= n < M } { Display n/1024 GetIndStr(935,f+2) }
            GetIndString(s, 935, f+2);
            GetIndString(dot, 935, 1);
            if n>=1024000 then begin
                n := n div 1024;
                s := concat(NumToStr(n),s);
            end else if n>=102400 then begin
                n:= n*10 div 1024;
                s := concat(NumToStr(n div 10),dot,NN(n mod 10,1),s);
            end else if n>=10240 then begin
                n:= n*100 div 1024;
                s := concat(NumToStr(n div 100),dot,NN(n mod 100,2),s);
            end else begin
                n := n*1000 div 1024;
                s := concat(NumToStr(n div 1000),dot,NN(n mod 1000,3),s);
            end;
        end;
        NumToK:=s;
    end;

    function NumToStr (n: longint): Str15;
        var
            s: Str255;
    begin
        NumToString(n, s);
        NumToStr := s;
    end;

    function UNumToStr( n: longint ): Str15;
        var
            s: Str15;
    begin
        s := chr(48 + (n mod 10 + 10 + (6 * ord(n < 0))) mod 10);
        n := BAND(BSR(n, 1), $7FFFFFFF) div 5;
        while n <> 0 do begin
            s := chr( n mod 10 + 48 ) + s;
            n := n div 10;
        end;
        UNumToStr := s;
    end;

    function SafeNumToStr( n: longint ): Str15;
        var
            s: Str15;
            negative: boolean;
    begin
        if n = $8000000 then begin
            SafeNumToStr := '-2147483648';
        end else begin
            negative := n < 0;
            n := abs(n);
            s := '';
            repeat
                s := chr( n mod 10 + 48 ) + s;
                n := n div 10;
            until n = 0;
            if negative then begin
                s := '-' + s;
            end;
        end;
        SafeNumToStr := s;
    end;

    function SafeStrToNum( const s: string; var n: longint ): boolean;
        var
            negative: boolean;
            i: longint;
    begin
        SafeStrToNum := false;
        negative := false;
        n := 0;
        i := 1;
        if (i <= length(s)) & (s[i] = '-') then begin
            negative := true;
            Inc(i);
        end;
        if i <= length(s) then begin
            SafeStrToNum := true;
            while i <= length(s) do begin
                if s[i] in ['0'..'9'] then begin
                    n := n * 10 + ord(s[i]) - 48;
                end else begin
                    SafeStrToNum := false;
                    leave;
                end;
                Inc(i);
            end;
        end;
        if negative then begin
            n := -n;
        end;
    end;

    function NN (n: longint; len: integer): Str15;
        var
            s: Str255;
    begin
        if len > 15 then begin
            len := 15;
        end;
        NumToString(n, s);
        while length(s) < len do begin
            s := concat('0', s);
        end;
        NN := s;
    end;

    function N2 (n: longint): Str15;
    begin
        N2 := NN(n, 2);
    end;

    function HexN (n: longint): Char;
    begin
        n := BAND(n, $000F);
        if n >= 10 then begin
            n := n + 7;
        end;
        n := n + 48;
        HexN := Chr(n);
    end;

    function HexN2 (n: longint): Str15;
    begin
        HexN2 := concat(HexN(BSR(n, 4)), HexN(n));
    end;

    function HexNN (n: longint; len: integer): Str15;
        var
            s: Str15;
    begin
        if len > 15 then begin
            len := 15;
        end;
        s := HexN(n);
        while length(s) < len do begin
            n := BAND(BSR(n, 4), $0FFFFFFF);
            s :=concat(HexN(n), s);
        end;
        HexNN := s;
    end;

    function HexToNum (s: Str15): longint;
        var
            n: longint;
            i, v: integer;
    begin
        i := 1;
        n := 0;
        while (i <= length(s)) & (s[i] in ['A'..'Z', 'a'..'z', '0'..'9']) do begin
            case s[i] of
                'A'..'Z':
                    v := ord(s[i]) - 55;
                'a'..'z':
                    v := ord(s[i]) - 87;
                '0'..'9':
                    v := ord(s[i]) - 48;
            end;
            n := BSL(n, 4) + v;
            i := i + 1;
        end;
        HexToNum := n;
    end;

    function StrToNum (s: Str255): longint;
        var
            n: longint;
    begin
        StringToNum(s, n);
        StrToNum := n;
    end;

    procedure DotDotDot (var s: Str255; var width: integer);
        var
            maxwidth, len: integer;
    begin
        maxwidth := width;
        width := StringWidth(s);
        if width > maxwidth then begin
            width := width + CharWidth('…');
{$PUSH}
{$R-}
            len := ord(s[0]);
            while (len > 0) and (width > maxwidth) do begin
                width := width - CharWidth(s[len]);
                len := len - 1;
            end;
            len := len + 1;
            s[0] := chr(len);
            s[len] := '…';
{$POP}
        end;
    end;

    function CountSICN( typ: OSType; id: integer ): integer;
        var
            sh: Handle;
    begin
        sh := GetResource( typ, id );
        if sh = nil then begin
            CountSICN := 0;
        end else begin
            CountSICN := MGetHandleSize( sh ) div 32;
        end;
    end;

    procedure PlotSICN (typ:OSType; id, index, v, h: integer);
        var
            sh: Handle;
            bm: BitMap;
            r: Rect;
            gp: GrafPtr;
    begin
        sh := GetResource(typ, id);
        Assert( sh <> nil );
        if sh <> nil then begin
            HLock(sh);
            bm.baseAddr := Ptr(longint(sh^) + (index - 1) * 32);
            bm.rowBytes := 2;
            SetRect(r, h, v, h + 16, v + 16);
            bm.bounds := r;
            GetPort(gp);
            CopyBits(bm, gp^.portBits, r, r, srcCopy, nil);
            HUnlock(sh);
            HPurge(sh);
        end;
    end;

    function LookupStrH (id: integer; match: Str255): Str255;
        var
            t, s: Str255;
            i: integer;
    begin
        t := '';
        i := 1;
        repeat
            GetIndString(s, id, i);
            if s = match then begin
                GetIndString(t, id, i + 1);
                leave;
            end;
            i := i + 2;
        until s = '';
        LookupStrH := t;
    end;

    function LookupStrhNumber (id: integer; n: longint): Str255;
        var
            s, t: Str255;
    begin
        NumToString(n, s);
        t := LookupStrH(id, s);
        if t = '' then begin
            t := s;
        end;
        LookupStrhNumber := t;
    end;

    function DirtyKey (ch: char): boolean;
    begin
        DirtyKey := not (ord(ch) in [homeChar, endChar, helpChar, pageUpChar, pageDownChar, leftArrowChar, rightArrowChar, upArrowChar, downArrowChar]);
    end;

    function SendCharToIsDialogEvent (const er: EventRecord; cs: CharSet): boolean;
        var
            ch: char;
    begin
        SendCharToIsDialogEvent := true;
        if EventIsKeyDown( er ) & not EventHasCommandKey( er ) then begin
            ch := EventChar( er );
            if not (ch in (cs + [tab, del, bs])) & DirtyKey(ch) then begin
                SendCharToIsDialogEvent := false;
            end;
        end;
    end;

    function MyGetTrapAddress (trapword: integer): UniversalProcPtr;
    begin
        MyGetTrapAddress := UniversalProcPtr(NGetTrapAddress(trapword, TrapType(btst(trapword, 11))));
    end;

    procedure MySetTrapAddress (addr: UniversalProcPtr; trapword: integer);
    begin
        NSetTrapAddress(addr, trapword, TrapType(btst(trapword, 11)));
    end;

    procedure FixScrap;
        var
            scrap: ScrapStuffPtr;
            junk, offset: longint;
    begin
        scrap := InfoScrap;
        if scrap^.scrapHandle = nil then begin
            scrap^.scrapState := -1;
        end;
        junk := GetScrap(nil, 'XXXX', offset);
        junk := UnloadScrap;
    end;

    procedure HaveResources;
    begin
        if Get1Resource('BNDL', 128) = nil then begin
            SysBeep(1);
            ExitToShell;
        end;
    end;

    function MapErr( err: OSStatus ) : OSErr;
    begin
        if (err < -32768) or (err > 32767) then begin
            err := -32767;
        end; (* if *)
        MapErr := err;
    end;

    function RandBelow( n: longint ): longint;
        var
            junk: integer;
    begin
        Assert( n >= 1 );
        junk := Random();
        RandBelow := band(qd.randSeed, $7FFFFFFF) mod n;
    end;

    function RandBetween( a, b: longint ): longint;
        var
            result: longint;
    begin
        Assert( b >= a );
        if b <= a then begin
            result := a;
        end else begin
            result := RandBelow(b-a+1) + a;
        end;
        RandBetween := result;
    end;

    procedure AddOSErr( var err: OSErr; err2: OSErr );
    begin
        if err = noErr then begin
            err := err2;
        end;
    end;

    procedure AddOSStatus( var err: OSStatus; err2: OSStatus );
    begin
        if err = noErr then begin
            err := err2;
        end;
    end;

    procedure DrawCenteredString( h, v: integer; const s: string );
    begin
        MoveTo( h - StringWidth( s ) div 2, v );
        DrawString( s );
    end;

end.